home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / BARNET / COMPILER / SATHER / !Sather / Library / Containrs / sa / a_pq < prev    next >
Text File  |  1996-07-13  |  10KB  |  322 lines
  1. ---------------------------> Sather 1.1 source file <--------------------------
  2. -- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>
  3. -- Copyright (C) 1995, International Computer Science Institute
  4. -- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
  5. -- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
  6. -- LICENSE contained in the file: Sather/Doc/License of the
  7. -- Sather distribution. The license is also available from ICSI,
  8. -- 1947 Center St., Suite 600, Berkeley CA 94704, USA.
  9. -------------------------------------------------------------------
  10. class A_PQ{T < $IS_LT{T}} < $PQ{T} is
  11.    --  E is the element type. 
  12.    --  W is the weight type
  13.    -- Priority queue implemented using an array based heap.  Retrieves
  14.    -- maximal elements first.
  15.    -- 
  16.    -- Usage:
  17.    --    a: PQ{INT} := #(#ARRAY{INT}(|2,3,4,5|));
  18.    --    #OUT+a.pop+","+a.pop+","+a.pop; -- prints 5,4,3
  19.    --    wrap: PQMIN{INT}; -- Used as a class alias for the create below
  20.    --    a: PQ{PQMIN{INT}}:=#(|wrap.create(2),wrap.create(4),wrap.create(3)|);
  21.    --    #OUT+a.pop+","+a.pop+","+a.pop; -- prints 1,3,4
  22.    --    wrap: PQWT{STR,INT};
  23.    --    a: PQ{PQWT{STR,INT}}:=#(wrap.create("a",1),wrap.create("b",2)|);
  24.    --    #OUT+a.pop+","+a.pop+","+a.pop; -- prints "(b,2) (a,1)"
  25.    -- 
  26.    -- Design note: It is better to provide access to weight changing
  27.    -- methods via an auxilliary wrapper, since that permits external
  28.    -- objects to change the weight without searching through all
  29.    -- elements
  30.    private include COMPARE{T};
  31.    
  32.    private attr arr:ARRAY{T};                
  33.    readonly attr size:INT;           -- Bottom of queue, = number of elements.
  34.    
  35.    create:SAME is
  36.       -- A new empty priority queue.
  37.       res ::= new; 
  38.       res.arr:=#ARRAY{T}(2);    -- The first element goes into [1]
  39.       res.size := 0;
  40.       return(res);
  41.    end; -- create
  42.  
  43.    create_sized(n:INT):SAME pre n >= 1 is
  44.       -- A new empty priority queue, initially sized to hold `n' elements.
  45.       res::=new; 
  46.       res.arr:=#ARRAY{T}(n+1);
  47.       res.size := 0;
  48.       return(res);
  49.    end; -- create_sized
  50.    
  51.    create(a: $ELT{T}): SAME is
  52.       -- Return a new priority queue constructed out of the elements of
  53.       -- "a"
  54.       res ::= #SAME;
  55.       loop res.insert(a.elt!) end;
  56.       return res;
  57.    end;
  58.    
  59.    create_from(a: ARRAY{T}): SAME is
  60.       -- Permits use of the literal syntax using type inference
  61.       return #SAME(a);
  62.    end;
  63.    
  64.    is_empty:BOOL is
  65.       -- True if queue is empty.
  66.       return(size=0);
  67.    end; -- is_empty
  68.  
  69.    current: T is return top end;
  70.    
  71.    top:T pre ~is_empty is return(arr[1]) end;
  72.       -- Top element or `void' if empty.
  73.  
  74.    has(e: T): BOOL is 
  75.       -- Whether the queue has "e"
  76.       i::=1;  loop until!(i>size); 
  77.      if elt_eq(e,arr[i]) then return true; end;
  78.      i := i+1; 
  79.       end;
  80.       return false;
  81.    end;
  82.  
  83.    delete(e:T): T is
  84.       -- removes e from the heap if it is present and returns it
  85.       -- otherwise returns void
  86.       elm:T;
  87.       i::=1; 
  88.       loop until!(i>size);
  89.      if elt_eq(e, arr[i]) then
  90.         elm:=arr[i];
  91.         arr[i] := arr[size];
  92.         arr[size] := void;
  93.         size := size-1;
  94.         sift_dn(i,size);
  95.         return elm;
  96.      end;
  97.      i:=i+1;
  98.       end;
  99.       return elm;
  100.    end;
  101.    
  102.    remove: T is return pop end;
  103.    
  104.    pop:T pre ~is_empty is
  105.       -- Pops off the first element or `void' if empty.
  106.       res::=arr[1];
  107.       arr[1]:=arr[size];
  108.       arr[size]:=void;          -- forget so gc can get what was there
  109.       size:=size-1;             -- shrink queue
  110.       sift_dn(1,size);          -- fix up heap
  111.       return(res);
  112.    end; -- pop
  113.  
  114.    insert(e:T) is
  115.       -- Insert `e' into priority queue.
  116.       if size>=arr.asize-2 then -- resize if area full
  117.      -- i.e. insert location(size+1) >= size of array(arr.asize-1)
  118.      -- Since we start off with an array of size 0, need to add 2 below
  119.      new_arr ::= #ARRAY{T}(2*arr.asize);
  120.      loop new_arr.set!(arr.elt!) end;
  121.      arr := new_arr;    -- Should discard the old one
  122.          -- arr:=arr.extend(2*arr.asize) 
  123.       end; 
  124.       size:=size+1;
  125.       arr[size]:=e;             -- put new element at bottom
  126.       sift_up(1,size);           -- fix up the heap
  127.    end; -- insert
  128.  
  129.    insert(e: T): SAME is insert(e); return self end;
  130.    
  131.    bounded_insert(e: T, bnd: INT) is
  132.       -- Insert "e", then keep popping until there are fewer than "bnd"
  133.       -- elements left 
  134.       insert(e);
  135.       loop until!(size <= bnd); discard ::= pop; end;
  136.    end;
  137.  
  138.    pop!: T is
  139.       -- Yield the elemnts of the queue in priority order, emptying the queue
  140.       loop until!(is_empty); yield(pop); end;
  141.    end;
  142.  
  143.    elt!: T is
  144.       -- NOTE: In any order, NOT in priority order! 
  145.       -- That would be much more expensive, and is probably best done
  146.       -- by popping elemetns off and then putting them in another queue.
  147.       i::=1;  loop until!(i>size); yield(arr[i]); i := i+1; end;
  148.    end;
  149.    
  150.    clear is
  151.       -- Clear the queue.
  152.       arr.clear; size:=0;
  153.    end; -- clear
  154.    
  155.    check_heap:BOOL is
  156.       -- True if `self' is a legal heap.
  157.       res::=true;
  158.       i:INT:=1; loop until!(i>size); 
  159.          if 2*i<=size then
  160.         if arr[i] < arr[2*i] then res:=false; break!; end;
  161.          end; -- if
  162.          if 2*i+1<=size then
  163.         if arr[i] < arr[2*i+1] then res:=false; break!; end;
  164.          end; -- if
  165.          i:=i+1
  166.       end; -- loop
  167.       return(res);
  168.    end; -- check_heap
  169.  
  170.    private sift_up(l,u:INT) pre l>=1 and u>=1 and l<=u is
  171.       -- Makes an `l,u' heap from a `l,u-1' heap in area.
  172.       i:INT:=u; loop until!(i<=l);
  173.          j:INT := i.rshift(1);
  174.      if arr[i] < arr[j] then break!;
  175.          else 
  176.             te:T:=arr[j]; arr[j]:=arr[i]; arr[i]:=te; -- swap i and j
  177.             i := j
  178.          end -- if
  179.       end -- loop
  180.    end; -- sift_up
  181.    
  182.    private sift_dn(l,u:INT) pre  l>=0 and u>=0 is
  183.       -- Make an `l,u' heap from an `l+1,u' heap in area.
  184.       i:INT:=l;
  185.       loop
  186.          c:INT:= 2 * i;
  187.          if c>u then break! end;
  188.      -- bigger sib
  189.          if 1+c<=u and (arr[c] < arr[c+1]) then c:=c+1 end;
  190.      if ~(arr[i]<arr[c]) then break!;
  191.          else
  192.             te:T:=arr[c]; arr[c]:=arr[i]; arr[i]:=te; -- swap i and c
  193.             i:=c
  194.          end -- if
  195.       end -- loop
  196.    end; -- sift_dn
  197.  
  198.    str: STR is
  199.       -- Prints out a string version of the flist of the components 
  200.       -- that are under $STR
  201.       res ::= #FSTR("");
  202.       loop  res := res+",".separate!(elt_str(elt!)); end;
  203.       return(res.str);
  204.    end;
  205.  
  206.    elt_str(e: T): STR is
  207.       typecase e when $STR then return e.str else return "Unknown" end;
  208.    end;
  209.    
  210.    copy: SAME is
  211.       res ::= new;
  212.       res.arr := arr.copy;
  213.       res.size := size;
  214.       return res;
  215.    end;
  216.    
  217. end; -- class PQ
  218. -------------------------------------------------------------------
  219. immutable class PQMIN{T < $IS_LT{T}} < $IS_LT{PQMIN{T}} is
  220.    -- Wrapper that inverts the < behavior, so that the priority queue
  221.    -- will be sorted based on the > relationship i.e. minimal elements
  222.    -- will be extracted first
  223.    -- 
  224.    include COMPARABLE;
  225.    
  226.    attr element: T;
  227.    
  228.    create(e: T): SAME is
  229.       return element(e);
  230.    end;
  231.  
  232.    is_eq(e: SAME): BOOL is
  233.       return element = e.element;
  234.    end;
  235.    
  236.    is_lt(e:SAME):BOOL is 
  237.       -- Return true is self is GREATER than "e" i.e. invert the 
  238.       -- relationship
  239.       return element > e.element;
  240.    end;
  241.    
  242.    str(e: T): STR is
  243.       typecase e  when $STR then return e.str else return "Unknown" end;
  244.    end;
  245.    
  246. end;
  247. -------------------------------------------------------------------
  248. class PQWT{E, WTP < $NUMBER{WTP}} < $IS_LT{PQWT{E,WTP}} is
  249.    -- A wrapper class for priority queue elements in which a weight
  250.    -- (which is different from the element itself) is used
  251.    -- 
  252.    -- Design note: This is not a immutable class since it is sometimes to
  253.    -- be able to modify the weight of an inserted node without
  254.    -- removing the element This would not be possible if the inserted
  255.    -- element were a value type                                                
  256.    include COMPARABLE;
  257.    
  258.    attr weight:WTP;
  259.    attr element: E;
  260.    
  261.    create(node:E,weight: WTP): SAME is
  262.       res ::= new;
  263.       res.weight := weight;
  264.       res.element :=node;
  265.       return res;
  266.    end;
  267.    
  268.    is_lt(e: SAME):BOOL is return weight < e.weight end;
  269.  
  270.    is_eq(e: SAME): BOOL is return weight = e.weight end;
  271.    
  272.    str: STR  is 
  273.       res ::= "("+weight.str;
  274.       n: E := element;
  275.       typecase n  when $STR then res:=res+","+n.str; 
  276.       else return "Unknown" end;
  277.       res := res+")";
  278.       return res;
  279.    end;
  280.    
  281. end;
  282. -------------------------------------------------------------------
  283. class PQMINWT{E, WTP < $NUMBER{WTP}} < $IS_LT{PQMINWT{E,WTP}}, $STR is
  284.    -- A wrapper class for priority queue elements in which a weight
  285.    -- (which is different from the element itself) is used In
  286.    -- addition, the comparison function for the weight is reversed so
  287.    -- that smaller weights are considered larger. Thus, minimum elements
  288.    -- will be removed from the priority queue first
  289.    include COMPARABLE;
  290.    
  291.    attr weight:WTP;
  292.    attr element: E;
  293.    
  294.    create(node:E,weight: WTP): SAME is
  295.       res ::= new;
  296.       res.weight := weight;
  297.       res.element :=node;
  298.       return res;
  299.    end;
  300.    
  301.    is_lt(e: SAME):BOOL is return weight > e.weight end;
  302.    
  303.    is_eq(e: SAME):BOOL is return weight = e.weight end;
  304.    
  305.    str: STR  is 
  306.       res ::= "("+wtstr(weight);
  307.       n: E := element;
  308.       typecase n  when $STR then res:=res+","+n.str; 
  309.       else return "Unknown" end;
  310.       res := res+")";
  311.       return res;
  312.    end;
  313.    
  314.    wtstr(w:WTP): STR is
  315.       typecase w
  316.       when $STR then return w.str
  317.       else return "UnprintableWeight"; end
  318.    end;
  319. end;
  320. -------------------------------------------------------------------
  321.       
  322.